perm filename PT2.OLD[MSS,LCS] blob
sn#240994 filedate 1976-09-22 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 SUBROUTINE PT2
C00018 ENDMK
C⊗;
SUBROUTINE PT2
INTEGER VALID
DIMENSION VALID(6),NBAR(36)
DATA QLINE/140.0/,HX/2./,VALID/1,4,8,2,3,-2/,SLSP/11.0/
C QLINE=BASIC LINE LENGTH, HX=HEIGHT MULTIPLIER, ZL=LN. LNGTH FACTOR.
C ADD MORE TO VALID LATER *****
COMMON /SF/KL,RT,KP,STFSZ,NAMX
1 /IPG/IPG,JPG,BRACK,RSTNUM(8),RPSZ(8),RHGT(8)
COMMON RS,JA,CLEFQ,AA,RQ(16),KQ,NQ,JQ,JJQ,KBQ,NAQ
COMMON/STF/RSTFAC(-3/4),RSTJ2 /IVV/IV(200)
COMMON /POSI/STFF(-3/4),JJ2,JPQ /LLL/L,LL,I,RXQ
1/PX/KPN(1) /Q/Q(1) /PTR/KWDS(1) /XRN/RN(1)
EQUIVALENCE (RQ(2),R4),(R5,RQ(3)),(R6,RQ(4)),(R7,RQ(5))
1,(R8,RQ(6)),(R9,RQ(7)),(LCNT,IV(80)),(NDPY,IV(81))
C TRNSP'S Bb, F, BBb, A, G, Eb.
NAMQ='AAAAA'
5 FORMAT(F,2I)
IF(RS.NE.'OLD')GO TO 2000
CALL GETFIL('PARTS')
CALL FASTIN(RSTFAC,128)
CALL FASTIN(KPN,JJ2)
CALL FASTIN(Q,JPQ)
2000 IF(IPG.EQ.0)GO TO 140
TYPE 144
144 FORMAT(' STAFF SIZE, TRANSP. '$)
ACCEPT 5,RSTJ2,LL
IF(MOD(LL,7).EQ.0)GO TO 140
DO 40 L=1,6
40 IF(LL.EQ.VALID(L))GO TO 140
TYPE 240
GO TO 2000
240 FORMAT(' THIS TRANSP NOT OFFERED')
140 IF(RSTJ2.EQ.0)RSTJ2=.9
L=JJ2-2
TR=LL
IF(LL.NE.0)CALL TRNSP(L,TR)
I=L
KK=1
CC JJ=0
CC DO 7 K=1,L
CC N=PN(K)
CC IF(Q(N+1).NE.4)GO TO 7
CC JJ=JJ+1
C FOUND A BAR LINE
CC RN(JJ)=Q(N+3)
CC7 CONTINUE
CC ENDLN=RN(JJ)
ENDLN=ENDL(JJ)
C FUNCTION ENDL(JJ) (IN FAIL) DOES ALL ABOVE
NA=1000
N=0
TYPE 90,JJ
RA=0
90 FORMAT(' NUMBER OF BARS PER LINE: TOTAL BAR LINES='I3/)
ZLINE=QLINE
9 KL=0
XLINE=ZLINE
J=0
LL=0
DO 8 K=1,JJ
IF(RN(K).LT.XLINE)GO TO 8
KP=K-KL
C NUMBER OF BARS, THIS LINE
CC TYPE 89,KP
KL=K
J=J+1
IF(IV(J).NE.KP)LL=-1
IV(J)=KP
XLINE=RN(K)+ZLINE
IF(ENDLN-XLINE.LT.80.)XLINE=ENDLN
8 CONTINUE
IF(LL)TYPE 108,RA,(IV(K),K=1,J)
IF(RT)GO TO 105
108 FORMAT(F6.2,8(3I3,1X))
CC TYPE 108
CC108 FORMAT(/)
CC89 FORMAT('+',I3,$)
IF(J.GT.NA)GO TO 107
IF(N.EQ.0)GO TO 105
C SKIP IF FIRST TIME
IF(N.NE.KP)GO TO 106
IF(J.EQ.NA)GO TO 105
106 RT=.05
C SHRINK OR EXPAND?
RA=RA+RT
ZLINE=QLINE*RS/RA
CC IF(RA.GT.J)GO TO 107
GO TO 9
1107 TYPE 111,KA
107 FORMAT(' CAN''T DO IT!')
TYPE 107
105 TYPE 104,J
104 FORMAT(I4,' LINES - OR TYPE N1, N2 --'$)
KA=0
ACCEPT 5,RA,N,KL
C TYPE 0,n TO EXIT WITH n SPACING BETWEEN STAVES (2 IS DEFAULT)
IF(KL.NE.0)GO TO 110
C FOR SPECIFICATION OF HOW MANY BARS ON EACH LINE
C NO MORE THAN 36 NUMS, INCLUDING 0S (FOR PAGE MARKS)
IF(IPG)GO TO 611
DO 711 K=1,J
711 NBAR(K)=IV(K)
GO TO 811
611 IF(RA.EQ.0)GO TO 11
IF(ZLINE.EQ.QLINE)RS=J
NA=RA
RT=NA-RA
IF(RT)GO TO 109
RA=RA-.6
C CHECK THIS ↑↑↑ NUMBER!
IF(N.EQ.0)GO TO 90
109 ZLINE=QLINE*RS/RA
GO TO 9
111 FORMAT(36I)
110 REREAD 111,NBAR
811 DO 112 K=36,1,-1
KP=NBAR(K)
KA=KA+KP
112 IF(KP.EQ.0.AND.KA.EQ.0)KL=K
IF(KA.NE.JJ)GO TO 1107
C MISMATCH!
N=26-2*MOD(KL-1,12)
IF(N.EQ.26)N=0
C TO SPACE OUT STAVES VERTICALLY
11 RA=0
JEND=-1
XLINE=ZLINE
CLEF=-99
JSLUR=0
LC=1
SIG=CLEF
HX=2
SP=2.45
C DEFAULT VERT. SPACE UNITS
IF(N.EQ.0)GO TO 100
C SPACED OUT DEPENDING ON NUM OF LINES
HX=N
SP=SP+(HX-2.)*.11
100 KL=1
IF(JEND.EQ.0)GO TO 1000
103 FORMAT(' TYPE OUTPUT FILE NAME ',$)
102 FORMAT(A5)
TYPE 103
ACCEPT 102,NAMX
IF(NAMX.EQ.' ')NAMX=NAMQ
IF(LOOKF(NAMX).GE.0)GO TO 88
TYPE 88,NAMX
ACCEPT 102,L
IF(L.EQ.'N')GO TO 103
88 FORMAT(' WRITE OVER FILE ',A5,'???? '$)
1000 KP=1
JEND=0
C FLAG FOR PAGE END - WHEN -1
RT=2
J=KK
HGT=HX*2.
LB=0
MTR1=-1
DO 1 K=KK,I
N=KPN(K)
IF(Q(N+1).NE.4)GO TO 1
IF(KA.EQ.0)GO TO 334
LB=LB+1
C BAR COUNTER
IF(NBAR(LC).GT.LB)GO TO 1
C FOR SPECIFIED BARS
LC=LC+1
LB=0
IF(NBAR(LC).NE.0)GO TO 335
JEND=-1
LC=LC+1
GO TO 335
334 IF(Q(N+3).LT.XLINE)GO TO 1
C FOUND LAST BAR LINE.
335 RX=0
MTR1=-1
MTR2=-1
LL=KPN(K+1)
C TO ADD METER AT END OF BAR
RS=Q(LL+1)
IF(RS.LE.4)GO TO 3
IF(RS.EQ.18)MTR1=LL
C WHAT ABOUT REHRSL NUMS, ETC??
LL=KPN(K+2)
RS=Q(LL+1)
IF(RS.LE.4)GO TO 3
IF(RS.EQ.18)MTR2=LL
LL=KPN(K+3)
IF(Q(LL+1).EQ.18)MTR2=LL
IF(MTR1.GT.0)GO TO 3
MTR1=MTR2
MTR2=-1
C IN CASE IT SAW SOMETHING AHEAD OF NEW METER
3 JJ=KP
C PUTS IN STAFF
RS=3.
IF(RT.NE.0)GO TO 331
C NEXT FOR BOTTOM STAFF. PUTS IN SPACER.
RS=6.
CC R8=SP
331 IF(IPG)GO TO 411
RS=3
C WD CNT IS RS, HX IS CODE(8), ARRAYS AND JPG WERE SET UP IN MAIN.
HX=8
RZ=0
RX=RT
DO 611 JP=1,JPG
RT=RSTNUM(JP)
611 CALL STAFF(RS,HX,RZ,RHGT(JP),RPSZ(JP),RZ,RZ,RZ)
HX=JPG
RS=4.
RT=0
CALL STAFF(2.,RS,RZ,HX,RZ,RZ,RZ,RZ)
IF(BRACK.NE.0)CALL STAFF(5.,RS,RZ,HX,RZ,RZ,BRACK,RZ)
RT=RX
GO TO 511
411 CALL STAFF(RS,8.,0,HGT,RSTJ2,0,0,SP)
HGT=HGT-HX
511 IF(XLINE.EQ.ZLINE)GO TO 33
CC IF(XLINE.LT.ENDLN)GO TO 6
IF(JEND)GO TO 60
C FOR PREMATURE PAGE END
IF(K.NE.I)GO TO 6
IF(RT.EQ.0)GO TO 6
60 RX=RT
RT=0
CALL STAFF(6.,8.,0,0,0,0,1.,SP)
C PUTS IN SPACER
RT=RX
6 IF(JSLUR.EQ.0)GO TO 2333
LL=JSLUR
JSLUR=0
1333 CALL STAFF(5.,5.,0,Q(LL),Q(LL+1),SLSP,Q(LL+3),0)
2333 IF(JSL2.EQ.0)GO TO 333
LL=JSL2
C FOR 2ND SLUR AT END OF LINE.
JSL2=0
GO TO 1333
333 IF(CLEF.EQ.-99)GO TO 33
C ONLY STAFF FOR FIRST LINE AT TOP.
RX=10.*RSTJ2
C THE SPACER
CALL STAFF(3.,3.,1.,0,CLEF,0,0,0)
IF(SIG.EQ.-99)GO TO 33
RS=4.
R5=SIG
RX=CLEF
IF(R5.LT.50)GO TO 332
RX=IFIX((R5+50.)/100.)
R5=R5-RX*100.
C CLEF+SIG
332 CALL STAFF(RS,17.,11.0*RSTJ2,0,R5,RX,0,0)
RX=12.*RSTJ2
33 R4=RA
R5=Q(N+3)
RS=0
R7=RT
R8=RX
R9=200.
LL=0
L=K-J+1
CALL PTMOVE(Q,KPN(J))
RA=R5
31 IF(MTR1)GO TO 231
R=200.0+2.23*RSTJ2
CALL STAFF(Q(MTR1),Q(MTR1+1),R,0,Q(MTR1+5),Q(MTR1+6),0,0)
C PUTS METER AFTER END OF STAFF
IF(MTR2)GO TO 231
R=200.0+6.7*RSTJ2
CALL STAFF(Q(MTR2),Q(MTR2+1),R,0,Q(MTR2+5),Q(MTR2+6),0,0)
C PUTS METER AFTER END OF STAFF
231 KB=KL
131 DO 30 NA=KK,K
KWDS(KP)=KB
KP=KP+1
JK=KPN(NA)
R=Q(JK+1)
IF(R.EQ.5)GO TO 135
IF(R.NE.44)GO TO 35
135 RR=Q(JK+6)
IF(RR.LT.Q(JK+3))GO TO 635
C NEEDED WHEN DATA ON LINE HAS BEEN EXPANDED, NOT CONTRACTED.
IF(RR.LT.199.)GO TO 37
C CATCHES END OF SLUR AND VARIOUS LINES
CC 4/76 *********????????635 IF(R.EQ.5)GO TO 235
635 IF(R.NE.5)GO TO 37
C TO PUT SLUR ON NEXT LINE.
C*********** IS SOMETHING MISSING HERE???????? 4/76
235 IF(JSLUR.NE.0)GO TO 435
JSLUR=JK+4
GO TO 535
435 JSL2=JK+4
C FOR 2ND SLUR
535 RR=201
IF(Q(JK+8).LT.-1)RR=202
Q(JK+6)=RR
IF(R.EQ.5)GO TO 30
GO TO 38
35 IF(R.NE.2)GO TO 36
IF(Q(JK).LT.6.)GO TO 30
CC RR=Q(IFIX(PN(NA-1))+3)
RR=RIGHT(NA,-1)
IF(RR.GE.199.)RR=RX
CC Q(JK+3)=RR-1.6*RSTJ2+(Q(IFIX(PN(NA+1))+3)-RR)/2.
Q(JK+3)=RR-1.6*RSTJ2+(RIGHT(NA,1)-RR)/2.
C FUNCTION 'RIGHT' FINDS RIGHT ITEMS FOR CENTERING.
C CENTERS WHOLE REST
GO TO 30
36 IF(R.NE.3)GO TO 34
RR=Q(JK+5)
IF(Q(JK).LT.3)RR=0
CLEF=AMOD(RR,100.0)
GO TO 30
34 IF(R.NE.17)GO TO 37
SIG=Q(JK+5)
IF(Q(JK).GT.3)SIG=SIG+Q(JK+6)*100.
C CLEF # IN P6 WITH KEY SIGS.
C NEXT CHANGES CODE NUM BACK TO ORIGINAL
37 IF(R.LT.33)GO TO 30
38 Q(JK+1)=R/11.
30 KB=KPN(NA+1)-KPN(NA)+KB
CC DO 31 NA=IFIX(PN(KK)),IFIX(PN(K+1)-1.)
CC RN(KL)=Q(NA)
CC31 KL=KL+1
CC KK=K+1
CALL PSHFT(KK,K)
RS=RT
LL='J'
R4=0
R5=200
NA=L
L=KP-JJ
CALL PTMOVE(RN,KWDS(JJ))
DO 47 JJ2=JJ,KP
LL=KWDS(JJ2)
AA=RN(LL+1)
IF(AA.NE.10.AND.AA.NE.16)GO TO 347
DO 147 NN=JJ2+1,KP
MM=KWDS(NN)
IF(RN(MM+1).NE.16)GO TO 147
C FOUND THE NEXT TEXT AFTER TEXT OR NUMB.
IF(RN(MM).EQ.8)GO TO 47
C JUMP IF POS. IS ALREADY TAKEN CARE OF.
IF(AA.EQ.10)GO TO 247
C NEXT FOR TEXT FOLLOWING TEXT
IF(ABS(RN(MM+4)-RN(LL+4)).GE.4)GO TO 47
C JUMP IF ON DIFF. VERT. PLANE.
AA=(RN(LL+9)+4.)*RSTJ2*RN(LL+5)+RN(LL+3)
C SETS MINIMUM SPACE.
IF(RN(MM+3).LT.AA)RN(MM+3)=AA
GO TO 47
247 IF(ABS(RN(MM+4)-RN(LL+4)).GT.6)GO TO 47
C CHECKS VERT. POS.
AA=RN(LL+4)+7
IF(RN(MM+4)-AA.LT.0)RN(MM+4)=AA
C MOVE WORD TO RIGHT OF NUMBER IF IT WAS TOO CLOSE
GO TO 47
147 CONTINUE
GO TO 47
347 IF(AA.NE.5)GO TO 1047
C TO IMPROVE SLUR PARAMETERS
R8=RN(LL+8)
IF(RN(LL).LT.6)R8=0
IF(R8.GT.0)GO TO 47
C JUMP IF A BRACKET
R=RN(LL+6)
DO 647 NN=JJ2+1,KP
MM=KWDS(NN)
C THIS IS TO FIND SLURS AT END OF OLD LINES AND EXTEND THEM
IF(RN(MM+1).NE.4)GO TO 647
C FIND A BAR LINE
IF(RN(MM+3).GT.199.)GO TO 647
C IGNORE LAST BAR OR LINE.
IF(RN(MM).GT.2)GO TO 647
AA=ABS(RN(MM+3)-R)
IF(AA.GT.1.)GO TO 647
RN(LL+6)=R+4
GO TO 47
647 CONTINUE
R7=RN(LL+7)
R9=R-RN(LL+3)+(R8+1.)*2.
IF(R9.GT.7)GO TO 47
C NO WORK NEEDED. IT'S LONG ENOUGH
IF(RN(LL).GT.5)RN(LL+8)=-1
CC AA=.5
R=1.
IF(R7.LT.0)R=-R
CC IF(R7.GT.0)GO TO 547
CC AA=-AA
C THE DIP IS DOWN
CC R=-R
547 RN(LL+4)=RN(LL+4)+R
RN(LL+5)=RN(LL+5)+R
C WERE +AA ↑↑↑↑↑
RN(LL+7)=R
GO TO 47
1047 IF(AA.NE.6)GO TO 47
IF(RN(LL).LT.7)GO TO 47
IF(RN(LL+9).GT.200.)RN(LL+9)=0
C ********** FIX THIS IN GETPTS, MOVER. IT SHOULDN'T MOVE P9 ALWAYS.
47 CONTINUE
IF(IPG)GO TO 211
C NEXT FOR PAGE LAYOUT ONLY
DO 311 L=1,KP-1
J=KWDS(L)
C GETS BACK STAFF NUM.
311 IF(RN(J+1).NE.8)RN(J+2)=RN(J+2)*10.0
GO TO 2
211 IF(K.EQ.I)GO TO 2
L=NA
J=K+1
C SO IT DOESN'T GO THRU ALL DATA
RT=RT-1
XLINE=RA+ZLINE
IF(ENDLN-XLINE.LT.80.)XLINE=ENDLN
10 IF(KL.GT.1700.OR.KP.GT.190.OR.RT.OR.JEND)GO TO 2
1 IF(K.EQ.I)GO TO 3
2 KWDS(KP)=KB
J=1
JJ2=KP+1
JPQ=KB
C WRITES 1 EXTRA WORD
CALL PUTFIL(NAMX)
LCNT=0
NDPY=0
CALL FASTOU(RSTFAC,128)
CALL FASTOU(KWDS,JJ2)
CALL FASTOU(RN,JPQ)
TYPE 101,NAMX
IF(KK.GE.I)CALL EXIT
NAMX=NAMX+2
NAMQ=NAMX
CALL FINFIL
GO TO 100
101 FORMAT(1XA5)
END
CC SUBROUTINE STAFF(P0,P1, P3,P4,P5,P6,P7,P8)
CC COMMON/XRN/RN(2000) /SF/KL,RT,KP,RSTJ2,NAMX
CC COMMON /PTR/PWDS(250),L,LL,I,IX
CC PWDS(KP)=KL
CC KP=KP+1
CC RN(KL)=P0
CC RN(KL+1)=P1
CC RN(KL+2)=RT
CC RN(KL+3)=P3
CC RN(KL+4)=P4
CC RN(KL+5)=P5
CC IF(P0.LT.4.)GO TO 1
CC RN(KL+6)=P6
CC IF(P0.LT.5)GO TO 1
CC RN(KL+7)=P7
CC IF(P0.LT.6)GO TO 1
CC RN(KL+8)=P8
CC1 KL=KL+P0+3.
CC END
CC FUNCTION RIGHT(NA,J)
CC COMMON /PX/PN(1800) /Q/Q(9000)
CC K=NA+J
C J IS EITHER +1 OR -1
CC1 L=PN(K)
CC IF(Q(L+1).NE.16)GO TO 2
CC K=K+J
CC GO TO 1
CC2 RIGHT=Q(L+3)
CC END